home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Mindy / Mindy 1.2 - portable sources / comp / expand.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  71.8 KB  |  2,606 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: expand.c,v 1.21 94/11/28 07:16:02 wlott Exp $
  27. *
  28. * This file does source-to-source expansions.
  29. *
  30. \**********************************************************************/
  31.  
  32. #include "../compat/std-c.h"
  33.  
  34. #include "mindycomp.h"
  35. #include "src.h"
  36. #include "literal.h"
  37. #include "dup.h"
  38. #include "free.h"
  39. #include "sym.h"
  40. #include "expand.h"
  41. #include "info.h"
  42. #include "lose.h"
  43.  
  44. static void expand_expr(struct expr **ptr);
  45. static void expand_body(struct body *body, boolean top_level);
  46.  
  47.  
  48. /* Utilities */
  49.  
  50. static struct body *chain_bodies(struct body *body1, struct body *body2)
  51. {
  52.     if (body1->head == NULL) {
  53.     free(body1);
  54.     return body2;
  55.     }
  56.     else {
  57.     if (body2->head != NULL) {
  58.         *body1->tail = body2->head;
  59.         body1->tail = body2->tail;
  60.     }
  61.     free(body2);
  62.     return body1;
  63.     }
  64. }
  65.  
  66. static void bind_params(struct body *body, struct param_list *vars,
  67.             struct expr *expr)
  68. {
  69.     add_constituent(body, make_let(make_bindings(vars, expr)));
  70. }
  71.  
  72. static void bind_param(struct body *body, struct param *var, struct expr *expr)
  73. {
  74.     bind_params(body, push_param(var, make_param_list()), expr);
  75. }
  76.  
  77. static void bind_temp(struct body *body, struct id *id, struct expr *expr)
  78. {
  79.     bind_param(body, make_param(id, NULL), expr);
  80. }
  81.  
  82. static void add_expr(struct body *body, struct expr *expr)
  83. {
  84.     add_constituent(body, make_expr_constituent(expr));
  85. }
  86.  
  87. static void expand_param_list(struct param_list *params)
  88. {
  89.     struct param *p;
  90.     struct keyword_param *k;
  91.  
  92.     for (p = params->required_params; p != NULL; p = p->next)
  93.     if (p->type)
  94.         expand_expr(&p->type);
  95.     for (k = params->keyword_params; k != NULL; k = k->next) {
  96.     if (k->type)
  97.         expand_expr(&k->type);
  98.     if (k->def)
  99.         expand_expr(&k->def);
  100.     }
  101. }
  102.  
  103. static void expand_bindings(struct bindings *bindings)
  104. {
  105.     expand_param_list(bindings->params);
  106.     expand_expr(&bindings->expr);
  107. }
  108.  
  109. static void expand_rettypes(struct return_type_list *rettypes)
  110. {
  111.     struct return_type *r;
  112.  
  113.     for (r = rettypes->req_types; r != NULL; r = r->next)
  114.     if (r->type)
  115.         expand_expr(&r->type);
  116.     if (rettypes->rest_type)
  117.     expand_expr(&rettypes->rest_type);
  118. }
  119.  
  120. static void bind_rettypes(struct body *body,
  121.               struct return_type_list *rettypes)
  122. {
  123.     struct return_type *r;
  124.     struct arglist *list_args = make_argument_list();
  125.     struct symbol *ctype = sym_CheckType;
  126.     struct symbol *type_class = sym_Type;
  127.     struct symbol *object = sym_Object;
  128.  
  129.     for (r = rettypes->req_types; r != NULL; r = r->next) {
  130.     if (r->type) {
  131.         struct arglist *args = make_argument_list();
  132.         struct expr *type;
  133.  
  134.         add_argument(args, make_argument(r->type));
  135.         r->type = NULL;
  136.         add_argument(args, make_argument(make_varref(id(type_class))));
  137.         type = make_function_call(make_varref(id(ctype)), args);
  138.         r->temp = gensym();
  139.         bind_temp(body, id(r->temp), type);
  140.         add_argument(list_args,make_argument(make_varref(id(r->temp))));
  141.     }
  142.     else
  143.         add_argument(list_args, make_argument(make_varref(id(object))));
  144.     }
  145.     rettypes->req_types_list
  146.     = make_function_call(make_varref(id(sym_List)), list_args);
  147.  
  148.     if (rettypes->rest_type) {
  149.     struct arglist *args = make_argument_list();
  150.     add_argument(args, make_argument(rettypes->rest_type));
  151.     rettypes->rest_type = NULL;
  152.     add_argument(args, make_argument(make_varref(id(type_class))));
  153.     rettypes->rest_temp = gensym();
  154.     bind_temp(body, id(rettypes->rest_temp),
  155.           make_function_call(make_varref(id(ctype)), args));
  156.     rettypes->rest_temp_varref = make_varref(id(rettypes->rest_temp));
  157.     }
  158. }
  159.  
  160. static void expand_plist(struct plist *plist)
  161. {
  162.     if (plist) {
  163.     struct property *p;
  164.  
  165.     for (p = plist->head; p != NULL; p = p->next)
  166.         expand_expr(&p->expr);
  167.     }
  168. }
  169.  
  170. static void add_plist_arguments(struct arglist *args, struct plist *plist)
  171. {
  172.     struct property *prop, *next;
  173.  
  174.     for (prop = plist->head; prop != NULL; prop = next) {
  175.     struct literal *key = make_symbol_literal(prop->keyword);
  176.     add_argument(args, make_argument(make_literal_ref(key)));
  177.     add_argument(args, make_argument(prop->expr));
  178.     next = prop->next;
  179.     free(prop);
  180.     }
  181.     free(plist);
  182. }
  183.  
  184. static void change_to_setter(struct id *id)
  185. {
  186.     static char buf[256];
  187.     char *ptr;
  188.     struct symbol *sym = id->symbol;
  189.     int len = strlen((char *)sym->name);
  190.  
  191.     if (len + 8 > sizeof(buf))
  192.     ptr = malloc(len + 8);
  193.     else
  194.     ptr = buf;
  195.  
  196.     strcpy(ptr, (char *)sym->name);
  197.     strcpy(ptr+len, "-setter");
  198.  
  199.     id->symbol = symbol(ptr);
  200.  
  201.     if (ptr != buf)
  202.     free(ptr);
  203. }
  204.  
  205. static struct argument *make_find_var_arg(struct id *var)
  206. {
  207.     struct arglist *args = make_argument_list();
  208.     struct expr *expr;
  209.  
  210.     add_argument(args, make_argument(make_varref(dup_id(var))));
  211.     expr = make_function_call(make_varref(id(sym_FindVariable)), args);
  212.  
  213.     return make_argument(expr);
  214. }
  215.  
  216.  
  217. /* Method expander */
  218.  
  219. static void add_method_wrap(struct body *body, struct method *method)
  220. {
  221.     struct param_list *params = method->params;
  222.     struct param *p;
  223.     struct keyword_param *k;
  224.     struct arglist *list_args = make_argument_list();
  225.     struct symbol *ctype = sym_CheckType;
  226.     struct symbol *type_class = sym_Type;
  227.  
  228.     for (p = params->required_params; p != NULL; p = p->next) {
  229.     if (p->type) {
  230.         struct arglist *args = make_argument_list();
  231.         struct expr *expr;
  232.  
  233.         p->type_temp = gensym();
  234.         add_argument(args, make_argument(p->type));
  235.         add_argument(args, make_argument(make_varref(id(type_class))));
  236.         expr = make_function_call(make_varref(id(ctype)), args);
  237.         bind_temp(body, id(p->type_temp), expr);
  238.         p->type = NULL;
  239.         expr = make_varref(id(p->type_temp));
  240.         add_argument(list_args, make_argument(expr));
  241.     }
  242.     else {
  243.         struct expr *expr = make_varref(id(sym_Object));
  244.         add_argument(list_args, make_argument(expr));
  245.     }
  246.     }
  247.     method->specializers
  248.     = make_function_call(make_varref(id(sym_List)), list_args);
  249.  
  250.     for (k = params->keyword_params; k != NULL; k = k->next) {
  251.     if (k->type) {
  252.         struct arglist *args = make_argument_list();
  253.         struct expr *expr;
  254.  
  255.         k->type_temp = gensym();
  256.         add_argument(args, make_argument(k->type));
  257.         add_argument(args, make_argument(make_varref(id(type_class))));
  258.         expr = make_function_call(make_varref(id(ctype)), args);
  259.         bind_temp(body, id(k->type_temp), expr);
  260.         k->type = NULL;
  261.     }
  262.     }
  263.  
  264.     if (method->rettypes)
  265.     bind_rettypes(body, method->rettypes);
  266. }
  267.  
  268. static void bind_next_param(struct body *body, struct param_list *params)
  269. {
  270.     struct symbol *temp = gensym();
  271.     struct arglist *args;
  272.     struct expr *expr;
  273.     struct param *p;
  274.  
  275.     /* Make sure there is a #rest parameter if there are #key params. */
  276.     if (params->allow_keys && params->rest_param == NULL)
  277.     params->rest_param = id(gensym());
  278.  
  279.     /* Build the argument list for the call to make-next-method-function */
  280.     args = make_argument_list();
  281.     expr = make_varref(id(sym_MakeNextMethodFunction));
  282.  
  283.     /* If there is a #rest param, we are going to be calling apply */
  284.     if (params->rest_param)
  285.     add_argument(args, make_argument(expr));
  286.  
  287.     /* Pass the list of next methods as the first argument. */
  288.     add_argument(args, make_argument(make_varref(id(temp))));
  289.  
  290.     /* Pass all the required params. */
  291.     for (p = params->required_params; p != NULL; p = p->next)
  292.     add_argument(args, make_argument(make_varref(dup_id(p->id))));
  293.  
  294.     if (params->rest_param) {
  295.     /* Pass the rest param, and call apply. */
  296.     add_argument(args,
  297.              make_argument(make_varref(dup_id(params->rest_param))));
  298.     expr = make_function_call(make_varref(id(sym_Apply)), args);
  299.     }
  300.     else
  301.     /* Just call make-next-method-function */
  302.     expr = make_function_call(expr, args);
  303.  
  304.     /* Bind the original next_param to the results of make-next-method-fun */
  305.     bind_temp(body, params->next_param, expr);
  306.  
  307.     /* Change the next_param to the temp. */
  308.     params->next_param = id(temp);
  309. }
  310.  
  311. static void hairy_keyword(struct body *body, struct keyword_param *k)
  312. {
  313.     struct symbol *temp = gensym();
  314.     struct param *p = make_param(k->id, NULL);
  315.     int line = k->id->line;
  316.     struct arglist *args;
  317.     struct id *name;
  318.     struct expr *expr;
  319.  
  320.     name = id(temp);
  321.     name->line = line;
  322.     expr = make_varref(name);
  323.  
  324.     if (k->def) {
  325.     /* Bind the original id to:
  326.      *   if (temp == #unbound) default-expression else temp end
  327.      */
  328.     args = make_argument_list();
  329.     add_argument(args, make_argument(expr));
  330.     expr = make_literal_ref(make_unbound_literal());
  331.     add_argument(args, make_argument(expr));
  332.     expr = make_function_call(make_varref(id(sym_Eq)), args);
  333.     expr = make_if(expr, make_expr_body(k->def),
  334.                make_else(0, make_expr_body(make_varref(id(temp)))));
  335.     k->def = make_literal_ref(make_unbound_literal());
  336.     }
  337.  
  338.     if (k->type_temp) {
  339.     /* Wrap it with a call to check-type if it is typed. */
  340.     args = make_argument_list();
  341.     add_argument(args, make_argument(expr));
  342.     add_argument(args, make_argument(make_varref(id(k->type_temp))));
  343.     expr = make_function_call(make_varref(id(sym_CheckType)), args);
  344.     p->type_temp = k->type_temp;
  345.     }
  346.  
  347.     bind_param(body, p, expr);
  348.     
  349.     /* Change the keyword id to the temp. */
  350.     k->id = id(temp);
  351.     k->id->line = line;
  352. }
  353.  
  354. static struct body
  355.     *check_rettypes(struct body *form, struct return_type_list *rettypes)
  356. {
  357.     struct param_list *params = make_param_list();
  358.     struct param **param_tail = ¶ms->required_params;
  359.     struct return_type *r;
  360.     struct arglist *values = make_argument_list();
  361.     struct expr *fn;
  362.     struct symbol *ctype = sym_CheckType;
  363.  
  364.     r = rettypes->req_types;
  365.  
  366.     if (rettypes->restp) {
  367.     if (r == NULL && rettypes->rest_temp == NULL)
  368.         /* #rest <object> -- real easy to test. */
  369.         return form;
  370.     add_argument(values, make_argument(make_varref(id(sym_Values))));
  371.     }
  372.     else {
  373.     if (r == NULL) {
  374.         /* No results are returned -- hence it is easy to test their */
  375.         /* types. */
  376.         struct expr *expr = make_varref(id(sym_Values));
  377.         add_expr(form, make_function_call(expr, make_argument_list()));
  378.         return form;
  379.     }
  380.     else if (r->next == NULL) {
  381.         /* Only a single value is returned. */
  382.         struct arglist *args = make_argument_list();
  383.         struct body *body = make_body();
  384.         struct expr *expr;
  385.  
  386.         add_argument(args, make_argument(make_body_expr(form)));
  387.         if (r->temp) {
  388.         add_argument(args, make_argument(make_varref(id(r->temp))));
  389.         expr = make_varref(id(ctype));
  390.         }
  391.         else
  392.         expr = make_varref(id(sym_Values));
  393.         add_expr(body, make_function_call(expr, args));
  394.         return body;
  395.     }
  396.     }
  397.  
  398.     for (; r != NULL; r = r->next) {
  399.     struct symbol *temp = gensym();
  400.     struct param *param = make_param(id(temp), NULL);
  401.     struct expr *expr = make_varref(id(temp));
  402.     *param_tail = param;
  403.     param_tail = ¶m->next;
  404.     if (r->temp) {
  405.         struct arglist *args = make_argument_list();
  406.         add_argument(args, make_argument(expr));
  407.         add_argument(args, make_argument(make_varref(id(r->temp))));
  408.         expr = make_function_call(make_varref(id(ctype)), args);
  409.     }
  410.     add_argument(values, make_argument(expr));
  411.     }
  412.  
  413.     if (rettypes->restp) {
  414.     struct symbol *rest_temp = gensym();
  415.  
  416.     set_rest_param(params, id(rest_temp));
  417.     
  418.     if (rettypes->rest_temp) {
  419.         struct symbol *val_temp = gensym();
  420.         struct param_list *meth_params;
  421.         struct arglist *args;
  422.         struct body *body;
  423.         struct method *method;
  424.         struct expr *expr;
  425.  
  426.         args = make_argument_list();
  427.         add_argument(args, make_argument(make_varref(id(val_temp))));
  428.         add_argument(args,
  429.              make_argument(make_varref(id(rettypes->rest_temp))));
  430.         expr = make_function_call(make_varref(id(ctype)), args);
  431.         add_expr(body = make_body(), expr);
  432.     
  433.         meth_params = make_param_list();
  434.         meth_params = push_param(make_param(id(val_temp), NULL),
  435.                      meth_params);
  436.         method = make_method_description(meth_params, NULL, body);
  437.  
  438.         args = make_argument_list();
  439.         add_argument(args, make_argument(make_method_ref(method)));
  440.         add_argument(args, make_argument(make_varref(id(rest_temp))));
  441.         expr = make_function_call(make_varref(id(sym_Do)), args);
  442.  
  443.         add_expr(body = make_body(), expr);
  444.         add_expr(body, make_varref(id(rest_temp)));
  445.  
  446.         add_argument(values, make_argument(make_body_expr(body)));
  447.     }
  448.     else
  449.         add_argument(values, make_argument(make_varref(id(rest_temp))));
  450.  
  451.     fn = make_varref(id(sym_Apply));
  452.     }
  453.     else
  454.     fn = make_varref(id(sym_Values));
  455.  
  456.     {
  457.     struct body *body = make_body();
  458.     struct bindings *bind = make_bindings(params, make_body_expr(form));
  459.     add_constituent(body, make_let(bind));
  460.     add_expr(body, make_function_call(fn, values));
  461.     return body;
  462.     }
  463. }
  464.  
  465. static void expand_method_for_compile(struct method *method)
  466. {
  467.     struct param_list *params = method->params;
  468.     struct keyword_param *k;
  469.     struct body *body = make_body();
  470.  
  471.     if (params->next_param)
  472.     bind_next_param(body, method->params);
  473.  
  474.     for (k = params->keyword_params; k != NULL; k = k->next)
  475.     if ((k->def && k->def->kind != expr_LITERAL) || k->type_temp)
  476.         hairy_keyword(body, k);
  477.  
  478.     expand_param_list(params);
  479.  
  480.     if (method->rettypes)
  481.     method->body = check_rettypes(method->body, method->rettypes);
  482.  
  483.     method->body = chain_bodies(body, method->body);
  484.  
  485.     expand_body(method->body, FALSE);
  486. }
  487.  
  488.  
  489. /* defvar/defconst initializer generation. */
  490.  
  491. static struct method *make_initializer(char *kind, struct bindings *bindings)
  492. {
  493.     struct param_list *params = bindings->params;
  494.     struct param *param;
  495.     struct symbol *init = sym_InitVariable;
  496.     struct symbol *ctype = sym_CheckType;
  497.     struct symbol *type_class = sym_Type;
  498.     struct param_list *temps = make_param_list();
  499.     struct param **tail = &temps->required_params;
  500.     struct body *outer_body = make_body();
  501.     struct body *inner_body = make_body();
  502.     struct param *temp_param;
  503.     struct arglist *args, *init_args;
  504.     struct expr *expr;
  505.     struct symbol *type_temp, *temp;
  506.     int len;
  507.     char *debug_name;
  508.     struct method *res;
  509.     boolean first;
  510.  
  511.     len = strlen(kind) + 1 - strlen(", ");
  512.     for (param = params->required_params; param != NULL; param = param->next)
  513.     len += strlen(", ") + strlen((char *)param->id->symbol->name);
  514.     if (params->rest_param)
  515.     len += strlen(", #rest ") + strlen((char *)params->rest_param->symbol->name);
  516.     debug_name = malloc(len);
  517.     strcpy(debug_name, kind);
  518.  
  519.     first = TRUE;
  520.     for (param = params->required_params; param != NULL; param = param->next) {
  521.     if (first)
  522.         first = FALSE;
  523.     else
  524.         strcat(debug_name, ", ");
  525.     strcat(debug_name, (char *)param->id->symbol->name);
  526.  
  527.     temp = gensym();
  528.     temp_param = make_param(id(temp), NULL);
  529.     *tail = temp_param;
  530.     tail = &temp_param->next;
  531.  
  532.     if (param->type) {
  533.         type_temp = gensym();
  534.         args = make_argument_list();
  535.         add_argument(args, make_argument(param->type));
  536.         param->type = NULL;
  537.         add_argument(args, make_argument(make_varref(id(type_class))));
  538.         expr = make_function_call(make_varref(id(ctype)), args);
  539.         bind_temp(outer_body, id(type_temp), expr);
  540.     }
  541.     else
  542.         type_temp = NULL;
  543.     
  544.     init_args = make_argument_list();
  545.     add_argument(init_args, make_find_var_arg(param->id));
  546.     expr = make_varref(id(temp));
  547.     if (type_temp) {
  548.         args = make_argument_list();
  549.         add_argument(args, make_argument(expr));
  550.         add_argument(args, make_argument(make_varref(id(type_temp))));
  551.         expr = make_function_call(make_varref(id(ctype)), args);
  552.     }
  553.     add_argument(init_args, make_argument(expr));
  554.     if (type_temp)
  555.         add_argument(init_args, make_argument(make_varref(id(type_temp))));
  556.     else {
  557.         expr = make_literal_ref(make_false_literal());
  558.         add_argument(init_args, make_argument(expr));
  559.     }
  560.     add_expr(inner_body,
  561.          make_function_call(make_varref(id(init)), init_args));
  562.     }
  563.  
  564.     if (params->rest_param) {
  565.     if (first)
  566.         strcat(debug_name, "#rest ");
  567.     else
  568.         strcat(debug_name, ", #rest ");
  569.     strcat(debug_name, (char *)params->rest_param->symbol->name);
  570.     temp = gensym();
  571.     temps->rest_param = id(temp);
  572.     init_args = make_argument_list();
  573.     add_argument(init_args, make_find_var_arg(params->rest_param));
  574.     expr = make_varref(id(temp));
  575.     add_argument(init_args, make_argument(expr));
  576.     expr = make_literal_ref(make_false_literal());
  577.     add_argument(init_args, make_argument(expr));
  578.     add_expr(inner_body,
  579.          make_function_call(make_varref(id(init)), init_args));
  580.     }
  581.  
  582.     add_constituent(outer_body,
  583.             make_let(make_bindings(temps, bindings->expr)));
  584.     bindings->expr = NULL;
  585.  
  586.     outer_body = chain_bodies(outer_body, inner_body);
  587.  
  588.     add_expr(outer_body, make_literal_ref(make_false_literal()));
  589.     res = make_top_level_method(debug_name, outer_body);
  590.  
  591.     free(debug_name);
  592.  
  593.     return res;
  594. }
  595.  
  596.  
  597. /* define module and define library stuff. */
  598.  
  599. static struct literal *make_var_names_literal(struct variable_names *names)
  600. {
  601.     struct literal_list *guts = make_literal_list();
  602.     struct list_literal *res;
  603.     struct variable_name *name;
  604.  
  605.     for (name = names->head; name != NULL; name = name->next)
  606.     add_literal(guts, name->name);
  607.     res = (struct list_literal *)make_list_literal(guts);
  608.  
  609.     if (res->first) {
  610.     struct literal **prev, *cur, *scan;
  611.  
  612.     prev = &res->first->next;
  613.     while ((cur = *prev) != NULL) {
  614.         for (scan = res->first;
  615.          scan != cur;
  616.          scan = scan->next)
  617.         if (((struct symbol_literal *)cur)->symbol
  618.             == ((struct symbol_literal *)scan)->symbol)
  619.             break;
  620.         if (cur == scan)
  621.         prev = &cur->next;
  622.         else {
  623.         *prev = cur->next;
  624.         free(cur);
  625.         }
  626.     }
  627.     }
  628.  
  629.     return (struct literal *)res;
  630. }
  631.  
  632. static void expand_useopt_prefix(struct use_clause *use,
  633.                  struct prefix_option *option)
  634. {
  635.     use->prefix = option->prefix;
  636. }
  637.  
  638. static void expand_useopt_import(struct use_clause *use,
  639.                  struct import_option *option)
  640. {
  641.     use->import = make_var_names_literal(option->vars);
  642.  
  643.     if (option->renames->head != NULL) {
  644.     struct literal_list *guts = make_literal_list();
  645.     struct renaming *renaming;
  646.  
  647.     for (renaming = option->renames->head;
  648.          renaming != NULL;
  649.          renaming = renaming->next) {
  650.         struct literal_list *list = make_literal_list();
  651.         add_literal(list, renaming->from);
  652.         add_literal(guts, make_dotted_list_literal(list, renaming->to));
  653.     }
  654.     if (use->rename)
  655.         use->rename = make_dotted_list_literal(guts, use->rename);
  656.     else
  657.         use->rename = make_list_literal(guts);
  658.     }
  659. }
  660.  
  661. static void expand_useopt_exclude(struct use_clause *use,
  662.                   struct exclude_option *option)
  663. {
  664.     use->exclude = make_var_names_literal(option->vars);
  665. }
  666.  
  667. static void expand_useopt_rename(struct use_clause *use,
  668.                  struct rename_option *option)
  669. {
  670.     struct literal_list *guts = make_literal_list();
  671.     struct renaming *renaming;
  672.  
  673.     for (renaming = option->renames->head;
  674.      renaming != NULL;
  675.      renaming = renaming->next)
  676.     add_literal(guts,
  677.             make_dotted_list_literal(add_literal(make_literal_list(),
  678.                              renaming->from),
  679.                          renaming->to));
  680.     if (use->rename)
  681.     use->rename = make_dotted_list_literal(guts, use->rename);
  682.     else
  683.     use->rename = make_list_literal(guts);
  684. }
  685.  
  686. static void expand_useopt_export(struct use_clause *use,
  687.                  struct export_option *option)
  688. {
  689.     use->export = make_var_names_literal(option->vars);
  690. }
  691.  
  692. static void expand_useopt_import_all(struct use_clause *use,
  693.                      struct use_option *option)
  694. {
  695.     use->import = make_true_literal();
  696. }
  697.  
  698. static void expand_useopt_export_all(struct use_clause *use,
  699.                      struct use_option *option)
  700. {
  701.     use->export = make_true_literal();
  702. }
  703.  
  704. static void (*UseOptionExpanders[])() = {
  705.     expand_useopt_prefix, expand_useopt_import, expand_useopt_exclude,
  706.     expand_useopt_rename, expand_useopt_export,
  707.     expand_useopt_import_all, expand_useopt_export_all
  708. };
  709.  
  710. static void expand_use_clause(struct use_clause *use)
  711. {
  712.     struct use_option *option, *next;
  713.  
  714.     for (option = use->options; option != NULL; option = next) {
  715.     (*UseOptionExpanders[(int)option->kind])(use, option);
  716.     next = option->next;
  717.     free(option);
  718.     }
  719.     use->options = NULL;
  720.     if (use->import == NULL)
  721.     use->import = make_true_literal();
  722.     if (use->exclude == NULL)
  723.     use->exclude = make_list_literal(make_literal_list());
  724.     if (use->prefix == NULL)
  725.     use->prefix = make_false_literal();
  726.     if (use->rename == NULL)
  727.     use->rename = make_list_literal(make_literal_list());
  728.     if (use->export == NULL)
  729.     use->export = make_list_literal(make_literal_list());
  730. }
  731.  
  732. static void expand_defnamespace(struct defnamespace_constituent *c)
  733. {
  734.     struct use_clause *use;
  735.  
  736.     for (use = c->use_clauses; use != NULL; use = use->next)
  737.     expand_use_clause(use);
  738.     c->exported_literal = make_var_names_literal(c->exported_variables);
  739.     c->exported_variables = NULL;
  740.     c->created_literal = make_var_names_literal(c->created_variables);
  741.     c->created_variables = NULL;
  742. }
  743.  
  744.  
  745. /* Constituent expanders. */
  746.  
  747. static void expand_defconst_for_compile(struct defconst_constituent *c)
  748. {
  749.     c->tlf = make_initializer("Define Constant ", c->bindings);
  750.     expand_method_for_compile(c->tlf);
  751. }
  752.  
  753. static boolean expand_defconst_constituent(struct defconst_constituent **ptr,
  754.                        boolean top_level)
  755. {
  756.     if (top_level)
  757.     expand_defconst_for_compile(*ptr);
  758.     else
  759.     error((*ptr)->line, "define constant not at top-level");
  760.     return FALSE;
  761. }
  762.  
  763. static void expand_defvar_for_compile(struct defvar_constituent *c)
  764. {
  765.     c->tlf = make_initializer("Define Variable ", c->bindings);
  766.     expand_method_for_compile(c->tlf);
  767. }
  768.  
  769. static boolean expand_defvar_constituent(struct defvar_constituent **ptr,
  770.                      boolean top_level)
  771. {
  772.     if (top_level)
  773.     expand_defvar_for_compile(*ptr);
  774.     else
  775.     error((*ptr)->line, "define variable not at top-level");
  776.     return FALSE;
  777. }
  778.  
  779. static void expand_defmethod_for_compile(struct defmethod_constituent *c)
  780. {
  781.     struct method *method = c->method;
  782.     char *name = (char *)method->name->symbol->name;
  783.     char *debug_name = malloc(strlen(name) + sizeof("Define Method "));
  784.     struct symbol *defmeth = sym_DefineMethod;
  785.     struct body *body;
  786.     struct arglist *args;
  787.     struct expr *expr;
  788.  
  789.     body = make_body();
  790.     add_method_wrap(body, method);
  791.     args = make_argument_list();
  792.     add_argument(args, make_find_var_arg(method->name));
  793.     add_argument(args, make_argument(make_method_ref(c->method)));
  794.     add_expr(body, make_function_call(make_varref(id(defmeth)), args));
  795.     expr = make_literal_ref(make_symbol_literal(method->name->symbol));
  796.     add_expr(body, expr);
  797.  
  798.     strcpy(debug_name, "Define Method ");
  799.     strcat(debug_name, name);
  800.  
  801.     c->tlf = make_top_level_method(debug_name, body);
  802.  
  803.     free(debug_name);
  804.  
  805.     expand_method_for_compile(c->tlf);
  806. }
  807.  
  808. static boolean expand_defmethod_constituent(struct defmethod_constituent **ptr,
  809.                         boolean top_level)
  810. {
  811.     if (top_level)
  812.     expand_defmethod_for_compile(*ptr);
  813.     else
  814.     error((*ptr)->method->line, "define method not at top-level");
  815.     return FALSE;
  816. }
  817.  
  818. static void expand_defgeneric_for_compile(struct defgeneric_constituent *c)
  819. {
  820.     char *name = (char *)c->name->symbol->name;
  821.     char *debug_name = malloc(strlen(name) + sizeof("Define Generic "));
  822.     struct body *body = make_body();
  823.     struct arglist *init_args = make_argument_list();
  824.     struct expr *expr;
  825.  
  826.     strcpy(debug_name, "Define Generic ");
  827.     strcat(debug_name, name);
  828.  
  829.     add_argument(init_args, make_find_var_arg(c->name));
  830.  
  831.     {
  832.     struct arglist *list_args = make_argument_list();
  833.     struct param *p;
  834.  
  835.     for (p = c->params->required_params; p != NULL; p = p->next)
  836.         if (p->type) {
  837.         add_argument(list_args, make_argument(p->type));
  838.         p->type = NULL;
  839.         }
  840.         else {
  841.         expr = make_varref(id(sym_Object));
  842.         add_argument(list_args, make_argument(expr));
  843.         }
  844.     expr = make_function_call(make_varref(id(sym_List)), list_args);
  845.     add_argument(init_args, make_argument(expr));
  846.     }
  847.     
  848.     if (c->params->rest_param)
  849.     expr = make_literal_ref(make_true_literal());
  850.     else
  851.     expr = make_literal_ref(make_false_literal());
  852.     add_argument(init_args, make_argument(expr));
  853.  
  854.     if (c->params->allow_keys) {
  855.     struct arglist *list_args = make_argument_list();
  856.     struct keyword_param *k;
  857.  
  858.     for (k = c->params->keyword_params; k != NULL; k = k->next) {
  859.         expr = make_literal_ref(make_symbol_literal(k->keyword));
  860.         add_argument(list_args, make_argument(expr));
  861.     }
  862.     expr = make_function_call(make_varref(id(sym_List)), list_args);
  863.     add_argument(init_args, make_argument(expr));
  864.     }
  865.     else {
  866.     expr = make_literal_ref(make_false_literal());
  867.     add_argument(init_args, make_argument(expr));
  868.     }
  869.  
  870.     expr = make_literal_ref(c->params->all_keys
  871.                 ? make_true_literal()
  872.                 : make_false_literal());
  873.     add_argument(init_args, make_argument(expr));
  874.  
  875.     if (c->rettypes) {
  876.     bind_rettypes(body, c->rettypes);
  877.     add_argument(init_args, make_argument(c->rettypes->req_types_list));
  878.     if (c->rettypes->rest_temp)
  879.         expr = c->rettypes->rest_temp_varref;
  880.     else if (c->rettypes->restp)
  881.         expr = make_literal_ref(make_true_literal());
  882.     else
  883.         expr = make_literal_ref(make_false_literal());
  884.     add_argument(init_args, make_argument(expr));
  885.     }
  886.     else {
  887.     expr = make_literal_ref(make_list_literal(make_literal_list()));
  888.     add_argument(init_args, make_argument(expr));
  889.     expr = make_literal_ref(make_true_literal());
  890.     add_argument(init_args, make_argument(expr));
  891.     }
  892.     if (c->plist) {
  893.     add_plist_arguments(init_args, c->plist);
  894.     c->plist = NULL;
  895.     }
  896.  
  897.     expr = make_function_call(make_varref(id(sym_DefineGeneric)),
  898.                   init_args);
  899.     add_expr(body, expr);
  900.     add_expr(body, make_literal_ref(make_symbol_literal(c->name->symbol)));
  901.  
  902.     c->tlf = make_top_level_method(debug_name, body);
  903.  
  904.     free(debug_name);
  905.  
  906.     expand_method_for_compile(c->tlf);
  907. }
  908.  
  909. static boolean
  910.     expand_defgeneric_constituent(struct defgeneric_constituent **ptr,
  911.                   boolean top_level)
  912. {
  913.     if (top_level)
  914.     expand_defgeneric_for_compile(*ptr);
  915.     else
  916.     error((*ptr)->name->line, "define generic not at top-level");
  917.     return FALSE;
  918. }
  919.  
  920. static void expand_slots(struct body *body,
  921.              struct arglist *defclass_args,
  922.              struct defclass_constituent *c)
  923. {
  924.     struct slot_spec *slot;
  925.     struct arglist *list_args = make_argument_list();
  926.     struct expr *expr;
  927.  
  928.     for (slot = c->slots; slot != NULL; slot = slot->next) {
  929.     struct arglist *slot_args;
  930.     boolean default_setter = TRUE;
  931.     
  932.     /* Extract the setter name, if there is one */
  933.     if (slot->plist) {
  934.         struct property *prop, **prev;
  935.         prev = &slot->plist->head;
  936.         while ((prop = *prev) != NULL) {
  937.         if (prop->keyword == sym_Setter) {
  938.             if (prop->expr->kind == expr_LITERAL
  939.             && ((struct literal_expr *) (prop->expr))
  940.             ->lit->kind == literal_FALSE) {
  941.             default_setter = FALSE;
  942.             *prev = prop->next;
  943.             free(prop);
  944.             }
  945.             else if (prop->expr->kind != expr_VARREF) {
  946.             error(prop->line, "Bogus %s in slot %s",
  947.                   prop->keyword->name,
  948.                   slot->name->symbol->name);
  949.             prev = &prop->next;
  950.             }
  951.             else {
  952.             struct varref_expr *v = (void *) prop->expr;
  953.             slot->setter = v->var;
  954.             *prev = prop->next;
  955.             free(prop);
  956.             }
  957.         }
  958.         else
  959.           prev = &prop->next;
  960.         }
  961.     }
  962.     
  963.     /* Bind the getter and setter names */
  964.     slot->getter = slot->name;
  965.     if (slot->setter == NULL && default_setter) {
  966.         slot->setter = dup_id(slot->name);
  967.         change_to_setter(slot->setter);
  968.     }
  969.     
  970.     /* Make the call to %define-slot */
  971.  
  972.     slot_args = make_argument_list();
  973.     add_argument(slot_args, make_find_var_arg(slot->getter));
  974.     if (slot->setter)
  975.       add_argument(slot_args, make_find_var_arg(slot->setter));
  976.     else {
  977.         expr = make_literal_ref(make_false_literal());
  978.         add_argument(slot_args, make_argument(expr));
  979.     }
  980.     expr = make_varref(id(sym_DefineSlot));
  981.     add_expr(body, make_function_call(expr, slot_args));
  982.     
  983.     /* Make the call to make-slot */
  984.  
  985.     slot_args = make_argument_list();
  986.     
  987.     /* First argument: the slot name */
  988.     expr = make_literal_ref(make_symbol_literal(slot->name->symbol));
  989.     add_argument(slot_args, make_argument(expr));
  990.     
  991.     /* Second argument: the allocation. */
  992.     expr = make_literal_ref(make_integer_literal((int) slot->alloc));
  993.     add_argument(slot_args, make_argument(expr));
  994.     
  995.     /* Third argument: the getter. */
  996.     add_argument(slot_args, make_argument(make_varref(slot->getter)));
  997.     
  998.     /* Fourth argument: the setter */
  999.     if (slot->setter == NULL)
  1000.       expr = make_literal_ref(make_false_literal());
  1001.     else
  1002.       expr = make_varref(slot->setter);
  1003.     add_argument(slot_args, make_argument(expr));
  1004.     
  1005.     /* Fifth argument: the type. */
  1006.     if (slot->type)
  1007.       add_argument(slot_args, make_argument(slot->type));
  1008.     else {
  1009.         expr = make_literal_ref(make_false_literal());
  1010.         add_argument(slot_args, make_argument(expr));
  1011.     }
  1012.     
  1013.     /* Sixth and on: the other properties. */
  1014.     if (slot->plist) {
  1015.         add_plist_arguments(slot_args, slot->plist);
  1016.         slot->plist = NULL;
  1017.     }
  1018.     
  1019.     expr = make_varref(id(sym_MakeSlot));
  1020.     expr = make_function_call(expr, slot_args);
  1021.     add_argument(list_args, make_argument(expr));
  1022.     }
  1023.     expr = make_function_call(make_varref(id(sym_List)), list_args);
  1024.     add_argument(defclass_args, make_argument(expr));
  1025. }
  1026.  
  1027. static void expand_initargs(struct body *body,
  1028.                 struct arglist *defclass_args,
  1029.                 struct defclass_constituent *c)
  1030. {
  1031.     struct initarg_spec *initarg;
  1032.     struct arglist *list_args = make_argument_list();
  1033.     struct expr *expr;
  1034.  
  1035.     for (initarg = c->initargs; initarg != NULL; initarg = initarg->next) {
  1036.     struct arglist *initarg_args = make_argument_list();
  1037.     
  1038.     /* Make the call to make-initarg */
  1039.     
  1040.     /* First argument: the slot name */
  1041.     expr = make_literal_ref(make_symbol_literal(initarg->keyword));
  1042.     add_argument(initarg_args, make_argument(expr));
  1043.     
  1044.     /* Second argument: required */
  1045.     if (initarg->required)
  1046.         expr = make_literal_ref(make_true_literal());
  1047.     else
  1048.         expr = make_literal_ref(make_false_literal());
  1049.     add_argument(initarg_args, make_argument(expr));
  1050.  
  1051.     /* Other arguments: properties */
  1052.     if (initarg->plist) {
  1053.         add_plist_arguments(initarg_args, initarg->plist);
  1054.         initarg->plist = NULL;
  1055.     }
  1056.     
  1057.     expr = make_varref(id(sym_MakeInitarg));
  1058.     expr = make_function_call(expr, initarg_args);
  1059.     add_argument(list_args, make_argument(expr));
  1060.     }
  1061.     expr = make_function_call(make_varref(id(sym_List)), list_args);
  1062.     add_argument(defclass_args, make_argument(expr));
  1063. }
  1064.  
  1065. static void expand_inheriteds(struct body *body,
  1066.                   struct arglist *defclass_args,
  1067.                   struct defclass_constituent *c)
  1068. {
  1069.     struct inherited_spec *inherited;
  1070.     struct arglist *list_args = make_argument_list();
  1071.     struct expr *expr;
  1072.  
  1073.     for (inherited = c->inheriteds; inherited != NULL;
  1074.      inherited = inherited->next) {
  1075.     struct arglist *inherited_args = make_argument_list();
  1076.     
  1077.     /* Make the call to make-inherited */
  1078.     
  1079.     /* First argument: the slot name */
  1080.     expr = make_literal_ref(make_symbol_literal(inherited->name->symbol));
  1081.     add_argument(inherited_args, make_argument(expr));
  1082.     
  1083.     /* Other arguments: properties */
  1084.     if (inherited->plist) {
  1085.         add_plist_arguments(inherited_args, inherited->plist);
  1086.         inherited->plist = NULL;
  1087.     }
  1088.     
  1089.     expr = make_varref(id(sym_MakeInherited));
  1090.     expr = make_function_call(expr, inherited_args);
  1091.     add_argument(list_args, make_argument(expr));
  1092.     }
  1093.     expr = make_function_call(make_varref(id(sym_List)), list_args);
  1094.     add_argument(defclass_args, make_argument(expr));
  1095. }
  1096.  
  1097. static void expand_defclass_for_compile(struct defclass_constituent *c)
  1098. {
  1099.     char *name = (char *)c->name->symbol->name;
  1100.     char *debug_name = malloc(strlen(name) + sizeof("Define Class "));
  1101.  
  1102.     strcpy(debug_name, "Define Class ");
  1103.     strcat(debug_name, name);
  1104.  
  1105.     /* Phase I: Create the class with its superclasses. */
  1106.  
  1107.     {
  1108.     struct arglist *list_args = make_argument_list();
  1109.     struct arglist *defclass_args = make_argument_list();
  1110.     struct body *body = make_body();
  1111.     struct superclass *super;
  1112.     struct expr *expr;
  1113.     
  1114.     add_argument(defclass_args, make_argument(make_varref(c->name)));
  1115.     for (super = c->supers; super != NULL; super = super->next)
  1116.         add_argument(list_args, make_argument(super->expr));
  1117.     expr = make_function_call(make_varref(id(sym_List)), list_args);
  1118.     add_argument(defclass_args, make_argument(expr));
  1119.  
  1120.     expr = make_varref(id(sym_DefineClass1));
  1121.     add_expr(body, make_function_call(expr, defclass_args));
  1122.     add_expr(body, make_literal_ref(make_symbol_literal(c->name->symbol)));
  1123.  
  1124.     c->tlf1 = make_top_level_method(debug_name, body);
  1125.     }
  1126.  
  1127.     /* Phase II: Create the slots, init args, and inherited slots. */
  1128.  
  1129.     {
  1130.     struct arglist *defclass_args = make_argument_list();
  1131.     struct body *body = make_body();
  1132.     struct expr *expr;
  1133.     
  1134.     add_argument(defclass_args, make_argument(make_varref(dup_id(c->name))));
  1135.  
  1136.     expand_slots(body, defclass_args, c);
  1137.     expand_initargs(body, defclass_args, c);
  1138.     expand_inheriteds(body, defclass_args, c);
  1139.  
  1140.     expr = make_varref(id(sym_DefineClass2));
  1141.     add_expr(body, make_function_call(expr, defclass_args));
  1142.     add_expr(body, make_literal_ref(make_symbol_literal(c->name->symbol)));
  1143.  
  1144.     c->tlf2 = make_top_level_method(debug_name, body);
  1145.     }
  1146.  
  1147.     free(debug_name);
  1148.  
  1149.     expand_method_for_compile(c->tlf1);
  1150.     expand_method_for_compile(c->tlf2);
  1151. }
  1152.  
  1153. static boolean expand_defclass_constituent(struct defclass_constituent **ptr,
  1154.                        boolean top_level)
  1155. {
  1156.     if (top_level)
  1157.     expand_defclass_for_compile(*ptr);
  1158.     else
  1159.     error((*ptr)->name->line, "define class not at top-level");
  1160.     return FALSE;
  1161. }
  1162.  
  1163. static boolean expand_expr_constituent(struct constituent **ptr,
  1164.                        boolean top_level)
  1165. {
  1166.     struct expr_constituent *c = (struct expr_constituent *)*ptr;
  1167.     struct expr *expr = c->expr;
  1168.  
  1169.     if (top_level) {
  1170.     if (expr->kind == expr_BODY) {
  1171.         struct body_expr *body_expr = (struct body_expr *)expr;
  1172.         expand_body(body_expr->body, TRUE);
  1173.         return FALSE;
  1174.     }
  1175.     else {
  1176.         *ptr = make_top_level_form("Top Level Form",
  1177.                        (struct constituent *)c);
  1178.         return TRUE;
  1179.     }
  1180.     }
  1181.     else {
  1182.     expand_expr(&c->expr);
  1183.     return FALSE;
  1184.     }
  1185. }
  1186.  
  1187. static boolean expand_local_constituent(struct constituent **ptr,
  1188.                     boolean top_level)
  1189. {
  1190.     struct local_constituent *c = (struct local_constituent *)*ptr;
  1191.     struct method *method = c->methods;
  1192.  
  1193.     if (top_level) {
  1194.     *ptr = make_top_level_form("Top Level Form", (struct constituent *)c);
  1195.     return TRUE;
  1196.     }
  1197.     else if (method != NULL && method->specializers == NULL) {
  1198.     struct body *body = make_body();
  1199.     for (; method != NULL; method = method->next_local)
  1200.         add_method_wrap(body, method);
  1201.     add_constituent(body, (struct constituent *)c);
  1202.     *ptr = make_expr_constituent(make_body_expr(body));
  1203.     return TRUE;
  1204.     }
  1205.     else {
  1206.     for (; method != NULL; method = method->next_local)
  1207.         expand_method_for_compile(method);
  1208.     expand_body(c->body, FALSE);
  1209.     return FALSE;
  1210.     }
  1211. }
  1212.  
  1213. static boolean expand_handler_constituent(struct constituent **ptr,
  1214.                       boolean top_level)
  1215. {
  1216.     struct handler_constituent *h = (struct handler_constituent *)*ptr;
  1217.     struct body *body;
  1218.     struct arglist *args;
  1219.  
  1220.     if (top_level) {
  1221.     *ptr = make_top_level_form("Top Level Form", (struct constituent *)h);
  1222.     return TRUE;
  1223.     }
  1224.  
  1225.     body = make_body();
  1226.     args = make_argument_list();
  1227.  
  1228.     add_argument(args, make_argument(h->type));
  1229.     add_argument(args, make_argument(h->func));
  1230.     if (h->plist) {
  1231.     add_plist_arguments(args, h->plist);
  1232.     h->plist = NULL;
  1233.     }
  1234.     add_expr(body, make_function_call(make_varref(id(sym_PushHandler)),
  1235.                       args));
  1236.  
  1237.  
  1238.     /* Link the handler body into the body we have just made, and replace */
  1239.     /* the handler body with it. */
  1240.     h->body = chain_bodies(body, h->body);
  1241.  
  1242.     /* Clear out the type and func */
  1243.     h->type = NULL;
  1244.     h->func = NULL;
  1245.  
  1246.     /* Now expand that body. */
  1247.     expand_body(h->body, FALSE);
  1248.  
  1249.     return FALSE;
  1250. }
  1251.  
  1252. static boolean expand_let_constituent(struct constituent **ptr,
  1253.                       boolean top_level)
  1254. {
  1255.     struct let_constituent *let = (struct let_constituent *)*ptr;
  1256.     struct bindings *bindings = let->bindings;
  1257.  
  1258.     if (top_level) {
  1259.     *ptr = make_top_level_form("Top Level Form",(struct constituent *)let);
  1260.     return TRUE;
  1261.     }
  1262.     else {
  1263.     struct param_list *params = bindings->params;
  1264.     struct body *body = NULL;
  1265.     struct param *p;
  1266.     struct arglist *args;
  1267.     struct expr *expr;
  1268.     struct symbol *check_type = sym_CheckType;
  1269.     struct symbol *type_class = sym_Type;
  1270.  
  1271.     for (p = params->required_params; p != NULL; p = p->next)
  1272.         if (p->type) {
  1273.         if (body == NULL)
  1274.             body = make_body();
  1275.         p->type_temp = gensym();
  1276.         args = make_argument_list();
  1277.         add_argument(args, make_argument(p->type));
  1278.         add_argument(args, make_argument(make_varref(id(type_class))));
  1279.         expr = make_function_call(make_varref(id(check_type)), args);
  1280.         bind_temp(body, id(p->type_temp), expr);
  1281.         p->type = NULL;
  1282.         }
  1283.     if (body != NULL) {
  1284.         p = params->required_params;
  1285.         if (p->next || params->rest_param) {
  1286.         /* There are multiple parameters, so we can't just wrap the */
  1287.         /* expression with check-type.  Therefore, we bind a bunch */
  1288.         /* of temps, and then bind the real variables to check-type */
  1289.         /* of the temps. */
  1290.         struct body *let_body = let->body;
  1291.         let->body = make_body();
  1292.         add_constituent(body, (struct constituent *)let);
  1293.         for (; p != NULL; p = p->next) {
  1294.             if (p->type_temp) {
  1295.             struct symbol *temp = gensym();
  1296.             struct param *new_param = make_param(p->id, NULL);
  1297.  
  1298.             p->id = id(temp);
  1299.             args = make_argument_list();
  1300.             add_argument(args,
  1301.                      make_argument(make_varref(id(temp))));
  1302.             expr = make_varref(id(p->type_temp));
  1303.             add_argument(args, make_argument(expr));
  1304.             expr = make_function_call(make_varref(id(check_type)),
  1305.                           args);
  1306.             bind_param(body, new_param, expr);
  1307.             }
  1308.         }
  1309.         add_expr(body, make_body_expr(let_body));
  1310.         }
  1311.         else {
  1312.         /* Wrap the expression with a call to check-type */
  1313.         args = make_argument_list();
  1314.         add_argument(args, make_argument(bindings->expr));
  1315.         add_argument(args,
  1316.                  make_argument(make_varref(id(p->type_temp))));
  1317.         expr = make_function_call(make_varref(id(check_type)), args);
  1318.         bindings->expr = expr;
  1319.         add_constituent(body, (struct constituent *)let);
  1320.         }
  1321.         *ptr = make_expr_constituent(make_body_expr(body));
  1322.         return TRUE;
  1323.     }
  1324.     else {
  1325.         expand_bindings(bindings);
  1326.         expand_body(let->body, FALSE);
  1327.         return FALSE;
  1328.     }
  1329.     }
  1330. }
  1331.  
  1332. static boolean expand_tlf_constituent(struct tlf_constituent **ptr,
  1333.                       boolean top_level)
  1334. {
  1335.     expand_method_for_compile((*ptr)->form);
  1336.     return FALSE;
  1337. }
  1338.  
  1339. static boolean expand_error_constituent(struct constituent **ptr)
  1340. {
  1341.     lose("Called expand on a parse tree with errors?");
  1342.     return FALSE;
  1343. }
  1344.  
  1345.  
  1346. static boolean
  1347.     expand_defnamespace_constituent(struct defnamespace_constituent **ptr,
  1348.                     boolean top_level)
  1349. {
  1350.     if (top_level)
  1351.     expand_defnamespace(*ptr);
  1352.     else
  1353.     error((*ptr)->name->line, "define %s not at top-level",
  1354.           (*ptr)->kind == constituent_DEFMODULE ? "module" : "library");
  1355.     return FALSE;
  1356. }
  1357.  
  1358. static boolean (*ConstituentExpanders[])() = {
  1359.     expand_defconst_constituent, expand_defvar_constituent,
  1360.     expand_defmethod_constituent, expand_defgeneric_constituent,
  1361.     expand_defclass_constituent, expand_expr_constituent,
  1362.     expand_local_constituent, expand_handler_constituent,
  1363.     expand_let_constituent, expand_tlf_constituent, expand_error_constituent,
  1364.     expand_defnamespace_constituent, expand_defnamespace_constituent
  1365. };
  1366.  
  1367. static boolean expand_constituent(struct constituent **ptr, boolean top_level)
  1368. {
  1369.     return (*ConstituentExpanders[(int)(*ptr)->kind])(ptr, top_level);
  1370. }
  1371.  
  1372.  
  1373. /* Block expander */
  1374.  
  1375. /* block/exit-fun forms:
  1376.  
  1377.     block (exit-fun)
  1378.       body
  1379.     end
  1380.  
  1381.     =>
  1382.  
  1383.     catch(method (temp)
  1384.             local
  1385.           method exit-fun (#rest rest)
  1386.             apply(throw, temp, rest)
  1387.           end;
  1388.         body
  1389.       end)
  1390.  
  1391.  */
  1392.  
  1393. static struct body *make_catch(int line, struct body *body,
  1394.                    struct id *exit_fun)
  1395. {
  1396.     struct symbol *temp = gensym();
  1397.     struct symbol *rest = gensym();
  1398.     struct param_list *params;
  1399.     struct arglist *args;
  1400.     struct body *new_body;
  1401.     struct method *method;
  1402.     struct local_methods *locals;
  1403.     struct expr *expr;
  1404.     struct id *name;
  1405.  
  1406.     /* Make the call to apply */
  1407.     args = make_argument_list();
  1408.     add_argument(args, make_argument(make_varref(id(sym_Throw))));
  1409.     add_argument(args, make_argument(make_varref(id(temp))));
  1410.     add_argument(args, make_argument(make_varref(id(rest))));
  1411.     expr = make_function_call(make_varref(id(sym_Apply)), args);
  1412.  
  1413.     /* Make the local method */
  1414.     params = set_rest_param(make_param_list(), id(rest));
  1415.     new_body = make_body();
  1416.     add_expr(new_body, expr);
  1417.     method = make_method_description(params, NULL, new_body);
  1418.     set_method_name(exit_fun, method);
  1419.  
  1420.     /* Make the local constituent, and add it to the outer body */
  1421.     locals = add_local_method(make_local_methods(), method);
  1422.     new_body = add_constituent(make_body(), make_local_constituent(locals));
  1423.  
  1424.     /* Chain the original body to the new body. */
  1425.     new_body = chain_bodies(new_body, body);
  1426.  
  1427.     /* Make the method arg to catch */
  1428.     params = push_param(make_param(id(temp), NULL), make_param_list());
  1429.     method = make_method_description(params, NULL, new_body);
  1430.     method->line = line;
  1431.  
  1432.     /* Make the call to catch */
  1433.     args = make_argument_list();
  1434.     add_argument(args, make_argument(make_method_ref(method)));
  1435.     name = id(sym_Catch);
  1436.     name->line = line;
  1437.     expr = make_function_call(make_varref(name), args);
  1438.  
  1439.     /* Return it. */
  1440.     return make_expr_body(expr);
  1441. }
  1442.  
  1443. /* block/exception forms:
  1444.  
  1445.    block ()
  1446.      block-body
  1447.    exception (symbol-1 :: type-1, plist-1...)
  1448.      exception-body-1
  1449.    exception (symbol-2 :: type-2, plist-2...)
  1450.      exception-body-2
  1451.    end
  1452.  
  1453.    get expanded into:
  1454.  
  1455.    block (done)
  1456.      block (do-handler)
  1457.        let handler (type-2, plist-2...)
  1458.          = method (symbol-2, ignore)
  1459.          do-handler(method () exception-body-2 end)
  1460.        end;
  1461.        let handler (type-1, plist-1...)
  1462.          = method (symbol-1, ignore)
  1463.          do-handler(method () exception-body-1 end)
  1464.        end;
  1465.        let (#rest results) = block-body;
  1466.        apply(done, results)
  1467.      end()
  1468.    end
  1469.  
  1470.  */
  1471.  
  1472. static struct body *make_handler_case(int line, struct body *block_body,
  1473.                       struct exception_clause *clauses)
  1474. {
  1475.     struct symbol *done = gensym();
  1476.     struct symbol *do_handler = gensym();
  1477.     struct symbol *results = gensym();
  1478.     struct exception_clause *next;
  1479.     struct expr *expr;
  1480.     struct param_list *params;
  1481.     struct arglist *args;
  1482.     struct method *method;
  1483.     struct body *handler_body;
  1484.     struct body *body = make_body();
  1485.     struct body *clause_body;
  1486.     
  1487.     while (clauses != NULL) {
  1488.     /* Wrap the exception body in a method */
  1489.     params = make_param_list();
  1490.     method = make_method_description(params, NULL, clauses->body);
  1491.  
  1492.     /* Make the handler method's body */
  1493.     args = make_argument_list();
  1494.     add_argument(args, make_argument(make_method_ref(method)));
  1495.     handler_body = make_body();
  1496.     add_expr(handler_body,
  1497.          make_function_call(make_varref(id(do_handler)), args));
  1498.  
  1499.     /* And make the handler method itself. */
  1500.     params = make_param_list();
  1501.     push_param(make_param(id(gensym()), NULL), params);
  1502.     if (clauses->condition)
  1503.         push_param(make_param(clauses->condition, NULL), params);
  1504.     else
  1505.         push_param(make_param(id(gensym()), NULL), params);
  1506.     method = make_method_description(params, NULL, handler_body);
  1507.  
  1508.     /* Add the handler to the body. */
  1509.     clause_body = make_body();
  1510.     add_constituent(clause_body,
  1511.             make_handler(clauses->type,
  1512.                      make_method_ref(method),
  1513.                      clauses->plist));
  1514.     body = chain_bodies(clause_body, body);
  1515.  
  1516.     /* Advance to the next clause. */
  1517.     next = clauses->next;
  1518.     free(clauses);
  1519.     clauses = next;
  1520.     }
  1521.     
  1522.     /* Invoke the block-body for multiple values. */
  1523.     params = set_rest_param(make_param_list(), id(results));
  1524.     add_constituent(body,
  1525.             make_let(make_bindings(params,
  1526.                        make_body_expr(block_body))));
  1527.  
  1528.     /* apply those results to the done exit function. */
  1529.     args = make_argument_list();
  1530.     args = add_argument(args, make_argument(make_varref(id(done))));
  1531.     args = add_argument(args, make_argument(make_varref(id(results))));
  1532.     expr = make_function_call(make_varref(id(sym_Apply)), args);
  1533.     add_expr(body, expr);
  1534.  
  1535.     /* make the do-handler block */
  1536.     expr = make_block(line, id(do_handler), body, NULL);
  1537.  
  1538.     /* Make a function call out of it. */
  1539.     expr = make_function_call(expr, make_argument_list());
  1540.  
  1541.     /* make the done block. */
  1542.     expr = make_block(line, id(done), make_expr_body(expr), NULL);
  1543.  
  1544.     /* And return it as a body. */
  1545.     return make_expr_body(expr);
  1546. }
  1547.  
  1548. static struct body *make_unwind_protect(struct body *body,struct body *cleanup)
  1549. {
  1550.     struct method *body_method
  1551.     = make_method_description(make_param_list(), NULL, body);
  1552.     struct method *cleanup_method
  1553.     = make_method_description(make_param_list(), NULL, cleanup);
  1554.     struct argument *body_arg
  1555.     = make_argument(make_method_ref(body_method));
  1556.     struct argument *cleanup_arg
  1557.     = make_argument(make_method_ref(cleanup_method));
  1558.     struct arglist *args
  1559.     = add_argument(add_argument(make_argument_list(), body_arg),
  1560.                cleanup_arg);
  1561.     struct expr *expr
  1562.     = make_function_call(make_varref(id(sym_Uwp)), args);
  1563.  
  1564.     return make_expr_body(expr);
  1565. }
  1566.  
  1567. static boolean expand_block_expr(struct expr **ptr)
  1568. {
  1569.     struct block_expr *e = (struct block_expr *)*ptr;
  1570.     struct body *body = e->body;
  1571.  
  1572.     if (e->inner)
  1573.     body = make_handler_case(e->line, body, e->inner);
  1574.     if (e->cleanup)
  1575.     body = make_unwind_protect(body, e->cleanup);
  1576.     if (e->outer)
  1577.     body = make_handler_case(e->line, body, e->outer);
  1578.     if (e->exit_fun)
  1579.     body = make_catch(e->line, body, e->exit_fun);
  1580.  
  1581.     *ptr = make_body_expr(body);
  1582.  
  1583.     free(e);
  1584.  
  1585.     return TRUE;
  1586. }
  1587.  
  1588.  
  1589. /* Case expander */
  1590.  
  1591. static struct expr *make_case_condition(struct condition *conditions)
  1592. {
  1593.     struct expr *cond = conditions->cond;
  1594.  
  1595.     if (conditions->next) {
  1596.     struct body *true_body
  1597.         = make_expr_body(make_literal_ref(make_true_literal()));
  1598.     struct body *rest_body
  1599.         = make_expr_body(make_case_condition(conditions->next));
  1600.  
  1601.     free(conditions);
  1602.  
  1603.     return make_if(cond, true_body, make_else(0, rest_body));
  1604.     }
  1605.     else {
  1606.     free(conditions);
  1607.     return cond;
  1608.     }
  1609. }
  1610.  
  1611. static struct expr *expand_case_body(struct condition_body *body)
  1612. {
  1613.     if (body) {
  1614.     struct condition_clause *clause = body->clause;
  1615.  
  1616.     if (clause->conditions) {
  1617.         struct expr *cond = make_case_condition(clause->conditions);
  1618.         struct expr *rest = expand_case_body(body->next);
  1619.     
  1620.         free(body);
  1621.  
  1622.         return make_if(cond, clause->body,
  1623.                make_else(0, make_expr_body(rest)));
  1624.     }
  1625.     else {
  1626.         free(body);
  1627.         return make_body_expr(clause->body);
  1628.     }
  1629.     }
  1630.     else
  1631.     return make_literal_ref(make_false_literal());
  1632. }
  1633.  
  1634. static boolean expand_case_expr(struct expr **ptr)
  1635. {
  1636.     struct case_expr *e = (struct case_expr *)*ptr;
  1637.  
  1638.     *ptr = expand_case_body(e->body);
  1639.  
  1640.     free(e);
  1641.  
  1642.     return TRUE;
  1643. }
  1644.  
  1645.  
  1646. /* For expander */
  1647.  
  1648. /* For loops expand into a body of code structured as follows:
  1649.  
  1650.    let temps;                <- outer body
  1651.    loop (repeat)
  1652.      let =/then & from vars;        <- middle body
  1653.      unless (implied-end-tests)        <- tests
  1654.        let in vars;            <- inner body
  1655.        unless (explicit-end-test)    <- until clause
  1656.          body;                <- step body
  1657.      steps;
  1658.      repeat
  1659.        end
  1660.      end
  1661.      finally
  1662.    end
  1663.  
  1664. */         
  1665.  
  1666. struct for_info {
  1667.     struct body *outer_body;
  1668.     struct body *middle_body;
  1669.     struct expr *first_test;
  1670.     struct binop_series *more_tests;
  1671.     struct body *inner_body;
  1672.     struct body *step_body;
  1673. };
  1674.  
  1675. static void cache_types(struct param_list *params, struct for_info *info)
  1676. {
  1677.     struct param *param;
  1678.  
  1679.     for (param = params->required_params; param != NULL; param = param->next) {
  1680.     if (param->type) {
  1681.         param->type_temp = gensym();
  1682.         bind_temp(info->outer_body, id(param->type_temp), param->type);
  1683.         param->type = NULL;
  1684.     }
  1685.     }
  1686. }
  1687.  
  1688. static void add_set(struct body *body, struct id *id, struct expr *expr)
  1689. {
  1690.     add_expr(body, make_varset(id, expr));
  1691. }
  1692.  
  1693. static void grovel_equal_then_for_clause(struct equal_then_for_clause *clause,
  1694.                      struct for_info *info)
  1695. {
  1696.     struct param_list *params = clause->vars;
  1697.     struct param *init_params_head = NULL;
  1698.     struct param **init_params_tail = &init_params_head;
  1699.     struct param_list *step_params = make_param_list();
  1700.     struct param *step_params_head = NULL;
  1701.     struct param **step_params_tail = &step_params_head;
  1702.     struct param *param, *next;
  1703.  
  1704.     bind_params(info->outer_body, params, clause->equal);
  1705.     bind_params(info->step_body, step_params, clause->then);
  1706.  
  1707.     for (param = params->required_params; param != NULL; param = next) {
  1708.     struct symbol *temp1 = gensym();
  1709.     struct symbol *temp2 = gensym();
  1710.     struct param *init_param = make_param(id(temp1), NULL);
  1711.     struct param *step_param = make_param(id(temp2), NULL);
  1712.  
  1713.     *init_params_tail = init_param;
  1714.     init_params_tail = &init_param->next;
  1715.     *step_params_tail = step_param;
  1716.     step_params_tail = &step_param->next;
  1717.  
  1718.     next = param->next;
  1719.     bind_param(info->middle_body, param, make_varref(id(temp1)));
  1720.     add_set(info->step_body, id(temp1), make_varref(id(temp2)));
  1721.     }
  1722.     params->required_params = init_params_head;
  1723.     step_params->required_params = step_params_head;
  1724.  
  1725.     if (params->rest_param) {
  1726.     struct id *rest = params->rest_param;
  1727.     struct symbol *temp1 = gensym();
  1728.     struct symbol *temp2 = gensym();
  1729.  
  1730.     params->rest_param = id(temp1);
  1731.     step_params->rest_param = id(temp2);
  1732.  
  1733.     bind_temp(info->middle_body, rest, make_varref(id(temp1)));
  1734.     add_set(info->step_body, id(temp1), make_varref(id(temp2)));
  1735.     }
  1736. }
  1737.  
  1738. static void add_test(struct expr *test, struct for_info *info)
  1739. {
  1740.     if (info->more_tests)
  1741.     info->more_tests
  1742.         = add_binop(info->more_tests, make_binop(id(sym_Or)), test);
  1743.     else {
  1744.     info->more_tests = make_binop_series();
  1745.     info->first_test = test;
  1746.     }
  1747. }
  1748.  
  1749. static void grovel_in_for_clause(struct in_for_clause *clause,
  1750.                  struct for_info *info)
  1751. {
  1752.     struct param *var = clause->vars->required_params;
  1753.     struct param *keyed_by = var->next;
  1754.     struct symbol *coll = gensym();
  1755.     struct symbol *state = gensym();
  1756.     struct symbol *limit = gensym();
  1757.     struct symbol *next = gensym();
  1758.     struct symbol *done = gensym();
  1759.     struct symbol *curkey = gensym();
  1760.     struct symbol *curel = gensym();
  1761.     struct param_list *params = make_param_list();
  1762.     struct expr *expr;
  1763.     struct arglist *args;
  1764.     struct bindings *bindings;
  1765.  
  1766.     /* Bind the collection. */
  1767.     bind_temp(info->outer_body, id(coll), clause->collection);
  1768.  
  1769.     /* Bind the iteration protocol */
  1770.     push_param(make_param(id(curel), NULL), params);
  1771.     push_param(make_param(id(curkey), NULL), params);
  1772.     push_param(make_param(id(done), NULL), params);
  1773.     push_param(make_param(id(next), NULL), params);
  1774.     push_param(make_param(id(limit), NULL), params);
  1775.     push_param(make_param(id(state), NULL), params);
  1776.     args = make_argument_list();
  1777.     add_argument(args, make_argument(make_varref(id(coll))));
  1778.     expr = make_varref(id(sym_ForwardIterationProtocol));
  1779.     bindings = make_bindings(params, make_function_call(expr, args));
  1780.     add_constituent(info->outer_body, make_let(bindings));
  1781.  
  1782.     /* Add the test for being done with the collection. */
  1783.     args = make_argument_list();
  1784.     add_argument(args, make_argument(make_varref(id(coll))));
  1785.     add_argument(args, make_argument(make_varref(id(state))));
  1786.     add_argument(args, make_argument(make_varref(id(limit))));
  1787.     add_test(make_function_call(make_varref(id(done)), args), info);
  1788.  
  1789.     /* Bind the users variable to the current element in the inner body. */
  1790.     args = make_argument_list();
  1791.     add_argument(args, make_argument(make_varref(id(coll))));
  1792.     add_argument(args, make_argument(make_varref(id(state))));
  1793.     expr = make_function_call(make_varref(id(curel)), args);
  1794.     bind_param(info->inner_body, var, expr);
  1795.  
  1796.     /* Bind the keyed_by variable if supplied. */
  1797.     if (keyed_by) {
  1798.     args = make_argument_list();
  1799.     add_argument(args, make_argument(make_varref(id(coll))));
  1800.     add_argument(args, make_argument(make_varref(id(state))));
  1801.     expr = make_function_call(make_varref(id(curkey)), args);
  1802.     bind_param(info->inner_body, keyed_by, expr);
  1803.     }
  1804.  
  1805.     /* Free the clauses param_list, because we've extracted the two params */
  1806.     /* from it. */
  1807.     free(clause->vars);
  1808.  
  1809.     /* Advance the state in the steps. */
  1810.     args = make_argument_list();
  1811.     add_argument(args, make_argument(make_varref(id(coll))));
  1812.     add_argument(args, make_argument(make_varref(id(state))));
  1813.     expr = make_function_call(make_varref(id(next)), args);
  1814.     add_set(info->step_body, id(state), expr);
  1815. }
  1816.  
  1817. static void grovel_from_for_clause(struct from_for_clause *clause,
  1818.                    struct for_info *info)
  1819. {
  1820.     struct symbol *temp = gensym();
  1821.     struct symbol *bound = NULL;
  1822.     struct symbol *by_temp = NULL;
  1823.     struct expr *by = NULL;
  1824.     struct arglist *args;
  1825.     struct expr *expr;
  1826.  
  1827.     /* Bind the start in the outer body. */
  1828.     bind_temp(info->outer_body, id(temp), clause->from);
  1829.  
  1830.     /* Bind the bound if there is one. */
  1831.     if (clause->to) {
  1832.     bound = gensym();
  1833.     bind_temp(info->outer_body, id(bound), clause->to);
  1834.     }
  1835.  
  1836.     /* Figure out what by should be, binding it if necessary. */
  1837.     if (clause->by) {
  1838.     by_temp = gensym();
  1839.     bind_temp(info->outer_body, id(by_temp), clause->by);
  1840.     by = make_varref(id(by_temp));
  1841.     }
  1842.     else if (clause->to_kind == to_ABOVE)
  1843.     by = make_literal_ref(make_integer_literal(-1));
  1844.     else
  1845.     by = make_literal_ref(make_integer_literal(1));
  1846.     
  1847.     /* Bind the user variable in the middle body. */
  1848.     bind_params(info->middle_body, clause->vars, make_varref(id(temp)));
  1849.  
  1850.     /* Add the end test. */
  1851.     switch (clause->to_kind) {
  1852.       case to_TO:
  1853.     if (by_temp) {
  1854.         struct expr *when_negative, *when_positive;
  1855.  
  1856.         args = make_argument_list();
  1857.         add_argument(args, make_argument(make_varref(id(temp))));
  1858.         add_argument(args, make_argument(make_varref(id(bound))));
  1859.         when_negative
  1860.         = make_function_call(make_varref(id(sym_Less)), args);
  1861.  
  1862.         args = make_argument_list();
  1863.         add_argument(args, make_argument(make_varref(id(bound))));
  1864.         add_argument(args, make_argument(make_varref(id(temp))));
  1865.         when_positive
  1866.         = make_function_call(make_varref(id(sym_Less)), args);
  1867.  
  1868.         args = make_argument_list();
  1869.         add_argument(args, make_argument(make_varref(id(by_temp))));
  1870.         expr = make_function_call(make_varref(id(sym_NegativeP)),
  1871.                       args);
  1872.  
  1873.         add_test(make_if(expr, make_expr_body(when_negative),
  1874.                  make_else(0, make_expr_body(when_positive))),
  1875.              info);
  1876.     }
  1877.     else {
  1878.         args = make_argument_list();
  1879.         add_argument(args, make_argument(make_varref(id(bound))));
  1880.         add_argument(args, make_argument(make_varref(id(temp))));
  1881.         add_test(make_function_call(make_varref(id(sym_Less)), args),
  1882.              info);
  1883.     }
  1884.     break;
  1885.  
  1886.       case to_ABOVE:
  1887.     args = make_argument_list();
  1888.     add_argument(args, make_argument(make_varref(id(temp))));
  1889.     add_argument(args, make_argument(make_varref(id(bound))));
  1890.     add_test(make_function_call(make_varref(id(sym_LessEqual)), args),
  1891.          info);
  1892.     break;
  1893.  
  1894.       case to_BELOW:
  1895.     args = make_argument_list();
  1896.     add_argument(args, make_argument(make_varref(id(bound))));
  1897.     add_argument(args, make_argument(make_varref(id(temp))));
  1898.     add_test(make_function_call(make_varref(id(sym_LessEqual)), args),
  1899.          info);
  1900.     break;
  1901.  
  1902.       case to_UNBOUNDED:
  1903.     break;
  1904.  
  1905.       default:
  1906.     lose("Bogus to kind in from for clause"); 
  1907.     }
  1908.  
  1909.     /* Advance the count by by */
  1910.     args = make_argument_list();
  1911.     add_argument(args, make_argument(make_varref(id(temp))));
  1912.     add_argument(args, make_argument(by));
  1913.     expr = make_function_call(make_varref(id(sym_Plus)), args);
  1914.     add_set(info->step_body, id(temp), expr);
  1915. }
  1916.  
  1917. static void (*ForClauseGrovelers[])() = {
  1918.     grovel_equal_then_for_clause,
  1919.     grovel_in_for_clause,
  1920.     grovel_from_for_clause
  1921. };
  1922.  
  1923. static boolean expand_for_expr(struct expr **ptr)
  1924. {
  1925.     struct for_expr *e = (struct for_expr *)*ptr;
  1926.     struct for_info info;
  1927.     struct repeat_expr *repeat;
  1928.     struct expr *expr;
  1929.     struct loop_expr *loop;
  1930.     struct for_clause *clause, *next;
  1931.  
  1932.     info.outer_body = make_body();
  1933.     info.middle_body = make_body();
  1934.     info.first_test = NULL;
  1935.     info.more_tests = NULL;
  1936.     info.inner_body = make_body();
  1937.     info.step_body = e->body;
  1938.  
  1939.     /* Grovel the clauses. */
  1940.     for (clause = e->clauses; clause != NULL; clause = next) {
  1941.     cache_types(clause->vars, &info);
  1942.     (*ForClauseGrovelers[(int)clause->kind])(clause, &info);
  1943.     next = clause->next;
  1944.     free(clause);
  1945.     }
  1946.  
  1947.     /* Add the call to repeat to the step body. */
  1948.     repeat = (struct repeat_expr *)make_repeat();
  1949.     add_expr(info.step_body, (struct expr *)repeat);
  1950.  
  1951.     /* Wrap the step body with the ``if (end-test) ...'' (if necessary) and */
  1952.     /* add it to the inner body. */
  1953.     if (e->until)
  1954.     expr = make_if(e->until, NULL, make_else(0, info.step_body));
  1955.     else
  1956.     expr = make_body_expr(info.step_body);
  1957.     add_expr(info.inner_body, expr);
  1958.  
  1959.     /* Wrap the inner body with the implicit end tests and add it to the */
  1960.     /* middle body */
  1961.     if (info.more_tests)
  1962.     expr = make_if(make_binop_series_expr(info.first_test,info.more_tests),
  1963.                NULL,
  1964.                make_else(0, info.inner_body));
  1965.     else
  1966.     expr = make_body_expr(info.inner_body);
  1967.     add_expr(info.middle_body, expr);
  1968.  
  1969.     /* Add the final part to the middle body */
  1970.     if (e->finally)
  1971.     add_expr(info.middle_body, make_body_expr(e->finally));
  1972.  
  1973.     /* Make the loop, and add it to the outer body. */
  1974.     loop = (struct loop_expr *)make_loop(info.middle_body);
  1975.     repeat->loop = loop;
  1976.     add_expr(info.outer_body, (struct expr *)loop);
  1977.  
  1978.     /* Change this expression into the outer body. */
  1979.     *ptr = make_body_expr(info.outer_body);
  1980.  
  1981.     /* Free the loop expression now that we are done with it. */
  1982.     free(e);
  1983.  
  1984.     return TRUE;
  1985. }
  1986.  
  1987.  
  1988. /* Select expander */
  1989.  
  1990. static struct expr
  1991.     *make_select_condition(struct condition *conditions,
  1992.                struct symbol *val, struct symbol *by)
  1993. {
  1994.     struct arglist *args
  1995.     = add_argument(add_argument(make_argument_list(),
  1996.                     make_argument(make_varref(id(val)))),
  1997.                make_argument(conditions->cond));
  1998.     struct expr *cond = make_function_call(make_varref(id(by)), args);
  1999.  
  2000.     if (conditions->next) {
  2001.     struct body *true_body
  2002.         = make_expr_body(make_literal_ref(make_true_literal()));
  2003.     struct body *rest_body
  2004.         = make_expr_body(make_select_condition(conditions->next, val, by));
  2005.  
  2006.     free(conditions);
  2007.  
  2008.     return make_if(cond, true_body, make_else(0, rest_body));
  2009.     }
  2010.     else {
  2011.     free(conditions);
  2012.     return cond;
  2013.     }
  2014. }
  2015.  
  2016. static struct expr *expand_select_body(struct condition_body *body,
  2017.                        struct symbol *val, struct symbol *by)
  2018. {
  2019.     if (body) {
  2020.     struct condition_clause *clause = body->clause;
  2021.  
  2022.     if (clause->conditions) {
  2023.         struct expr *cond
  2024.         = make_select_condition(clause->conditions, val, by);
  2025.         struct expr *rest = expand_select_body(body->next, val, by);
  2026.     
  2027.         free(body);
  2028.  
  2029.         return make_if(cond, clause->body,
  2030.                make_else(0, make_expr_body(rest)));
  2031.     }
  2032.     else {
  2033.         free(body);
  2034.         return make_body_expr(clause->body);
  2035.     }
  2036.     }
  2037.     else {
  2038.     struct expr *expr
  2039.         = make_literal_ref(make_string_literal("fell through select"));
  2040.     struct arglist *args
  2041.         = add_argument(make_argument_list(), make_argument(expr));
  2042.  
  2043.     return make_function_call(make_varref(id(sym_Error)), args);
  2044.     }
  2045. }
  2046.  
  2047. static boolean expand_select_expr(struct expr **ptr)
  2048. {
  2049.     struct select_expr *e = (struct select_expr *)*ptr;
  2050.     struct symbol *valtemp = gensym();
  2051.     struct symbol *bytemp = e->by ? gensym() : sym_Eq;
  2052.     struct body *body = make_body();
  2053.  
  2054.     bind_temp(body, id(valtemp), e->expr);
  2055.     if (e->by)
  2056.     bind_temp(body, id(bytemp), e->by);
  2057.  
  2058.     add_expr(body, expand_select_body(e->body, valtemp, bytemp));
  2059.  
  2060.     *ptr = make_body_expr(body);
  2061.  
  2062.     free(e);
  2063.  
  2064.     return TRUE;
  2065. }
  2066.  
  2067.  
  2068. /* Binop series expander */
  2069.  
  2070. static struct expr *make_binary_fn_call(struct id *op, struct expr *left,
  2071.                     struct expr *right)
  2072. {
  2073.     struct arglist *args
  2074.     = add_argument(add_argument(make_argument_list(),
  2075.                     make_argument(left)),
  2076.                make_argument(right));
  2077.     return make_function_call(make_varref(op), args);
  2078. }
  2079.  
  2080. static boolean expand_binop_series_expr(struct expr **ptr)
  2081. {
  2082.     struct binop_series_expr *e = (struct binop_series_expr *)*ptr;
  2083.     struct binop *stack = NULL;
  2084.     struct expr *left = e->first_operand;
  2085.     struct binop *op = e->first_binop;
  2086.     struct expr *right = op->operand;
  2087.     struct binop *next = op->next;
  2088.  
  2089.     while (next) {
  2090.     if (op->left_assoc
  2091.           ? (op->precedence >= next->precedence)
  2092.           : (op->precedence > next->precedence)) {
  2093.         /* We want to reduce left.op.right */
  2094.         struct expr *new = make_binary_fn_call(op->op, left, right);
  2095.         free(op);
  2096.         if (stack) {
  2097.         /* We want to reduce into right and pop the stack. */
  2098.         right = new;
  2099.         op = stack;
  2100.         stack = stack->next;
  2101.         left = op->operand;
  2102.         }
  2103.         else {
  2104.         /* We want to reduce into left and pop next. */
  2105.         left = new;
  2106.         op = next;
  2107.         right = op->operand;
  2108.         next = next->next;
  2109.         }
  2110.     }
  2111.     else {
  2112.         /* We want to shift this onto the stack. */
  2113.         op->operand = left;
  2114.         op->next = stack;
  2115.         stack = op;
  2116.         left = right;
  2117.         op = next;
  2118.         right = op->operand;
  2119.         next = next->next;
  2120.     }
  2121.     }
  2122.     while (1) {
  2123.     right = make_binary_fn_call(op->op, left, right);
  2124.     free(op);
  2125.     if (stack == NULL)
  2126.         break;
  2127.     op = stack;
  2128.     left = op->operand;
  2129.     stack = stack->next;
  2130.     }
  2131.  
  2132.     free(e);
  2133.  
  2134.     *ptr = right;
  2135.  
  2136.     return TRUE;
  2137. }
  2138.  
  2139.  
  2140. /* Simple expression expanders. */
  2141.  
  2142. static boolean expand_varref_expr(struct varref_expr **ptr)
  2143. {
  2144.     /* Nothing to do. */
  2145.     return FALSE;
  2146. }
  2147.  
  2148. static boolean expand_literal_expr(struct literal_expr **ptr)
  2149. {
  2150.     /* Nothing to do. */
  2151.     return FALSE;
  2152. }
  2153.  
  2154. static boolean expand_call_expr(struct call_expr **ptr)
  2155. {
  2156.     struct call_expr *e = *ptr;
  2157.     struct argument *arg;
  2158.  
  2159.     if (e->info && e->info->srctran) {
  2160.     if (e->func->kind != expr_VARREF)
  2161.         lose("Source-transforming a call where the function "
  2162.          "isn't a varref?");
  2163.     if ((*e->info->srctran)(ptr))
  2164.         return TRUE;
  2165.     }
  2166.  
  2167.     expand_expr(&e->func);
  2168.     for (arg = e->args; arg != NULL; arg = arg->next)
  2169.     expand_expr(&arg->expr);
  2170.     return FALSE;
  2171. }
  2172.  
  2173. static boolean expand_dot_expr(struct expr **ptr)
  2174. {
  2175.     struct dot_expr *e = (struct dot_expr *)*ptr;
  2176.  
  2177.     expand_expr(&e->arg);
  2178.     expand_expr(&e->func);
  2179.  
  2180.     return FALSE;
  2181. }
  2182.  
  2183. static struct literal *extract_literal(struct body *body)
  2184. {
  2185.     struct expr *expr;
  2186.  
  2187.     if (body->head == NULL)
  2188.     return make_false_literal();
  2189.     if (body->head->next != NULL)
  2190.     return NULL;
  2191.     if (body->head->kind != constituent_EXPR)
  2192.     return NULL;
  2193.     expr = ((struct expr_constituent *)body->head)->expr;
  2194.     if (expr->kind != expr_LITERAL)
  2195.     return NULL;
  2196.     else
  2197.     return ((struct literal_expr *)expr)->lit;
  2198. }
  2199.  
  2200. static boolean expand_if_expr(struct expr **ptr)
  2201. {
  2202.     struct if_expr *e = *(struct if_expr **)ptr;
  2203.  
  2204.     expand_expr(&e->cond);
  2205.  
  2206.     if (e->cond->kind == expr_LITERAL) {
  2207.     struct literal *lit = ((struct literal_expr *)e->cond)->lit;
  2208.     if (lit->kind == literal_FALSE) {
  2209.         free_body(e->consequent);
  2210.         *ptr = make_body_expr(e->alternate);
  2211.     }
  2212.     else {
  2213.         *ptr = make_body_expr(e->consequent);
  2214.         free_body(e->alternate);
  2215.     }
  2216.     free_expr(e->cond);
  2217.     free(e);
  2218.     return TRUE;
  2219.     }
  2220.  
  2221.     expand_body(e->consequent, FALSE);
  2222.     expand_body(e->alternate, FALSE);
  2223.  
  2224.     if (e->cond->kind == expr_IF) {
  2225.     struct if_expr *inner = (struct if_expr *)e->cond;
  2226.     struct literal *inner_consequent = extract_literal(inner->consequent);
  2227.     struct literal *inner_alternate = extract_literal(inner->alternate);
  2228.  
  2229.     if (inner_consequent && inner_alternate) {
  2230.         if (inner_consequent->kind != literal_FALSE)
  2231.         if (inner_alternate->kind != literal_FALSE) {
  2232.             /* They are both true.  So no matter what we are going */
  2233.             /* to only do the consequent.  But we need to eval the */
  2234.             /* condition none the less. */
  2235.             struct constituent *c = make_expr_constituent(inner->cond);
  2236.             c->next = e->consequent->head;
  2237.             e->consequent->head = c;
  2238.             if (c->next == NULL)
  2239.             e->consequent->tail = &c->next;
  2240.             free_body(e->alternate);
  2241.             *ptr = make_body_expr(e->consequent);
  2242.             free(e);
  2243.         }
  2244.         else {
  2245.             /* The inner consequent is true and the inner alternate */
  2246.             /* is false.  So we just use the inner condition. */
  2247.             e->cond = inner->cond;
  2248.         }
  2249.         else
  2250.         if (inner_alternate->kind != literal_FALSE) {
  2251.             /* The inner consequent is false and the inner alternate */
  2252.             /* is true.  Therefore, we use the inner condition but */
  2253.             /* which the consequent and alternate. */
  2254.             struct body *temp = e->consequent;
  2255.             e->cond = inner->cond;
  2256.             e->consequent = e->alternate;
  2257.             e->alternate = temp;
  2258.         }
  2259.         else {
  2260.             /* Both are false, so we always do the alternate. */
  2261.             struct constituent *c = make_expr_constituent(inner->cond);
  2262.             c->next = e->alternate->head;
  2263.             e->alternate->head = c;
  2264.             if (c->next == NULL)
  2265.             e->alternate->tail = &c->next;
  2266.             free_body(e->consequent);
  2267.             *ptr = make_body_expr(e->alternate);
  2268.             free(e);
  2269.         }
  2270.         free_body(inner->consequent);
  2271.         free_body(inner->alternate);
  2272.         free(inner);
  2273.         return FALSE;
  2274.     }
  2275.     else {
  2276.         struct body *consequent = dup_body(e->consequent);
  2277.         struct body *alternate = dup_body(e->alternate);
  2278.         if (consequent != NULL && alternate != NULL) {
  2279.         e->cond = inner->cond;
  2280.         e->consequent
  2281.             = make_expr_body(make_if(make_body_expr(inner->consequent),
  2282.                          e->consequent,
  2283.                          make_else(0, e->alternate)));
  2284.         e->alternate
  2285.             = make_expr_body(make_if(make_body_expr(inner->alternate),
  2286.                          consequent,
  2287.                          make_else(0, alternate)));
  2288.         free(inner);
  2289.  
  2290.         return TRUE;
  2291.         }
  2292.         else {
  2293.         if (consequent)
  2294.             free_body(consequent);
  2295.         if (alternate)
  2296.             free_body(alternate);
  2297.         return FALSE;
  2298.         }
  2299.     }
  2300.     }
  2301.     else
  2302.     return FALSE;
  2303. }
  2304.  
  2305. static boolean expand_varset_expr(struct varset_expr **ptr)
  2306. {
  2307.     struct varset_expr *e = *ptr;
  2308.  
  2309.     expand_expr(&e->value);
  2310.  
  2311.     return FALSE;
  2312. }
  2313.  
  2314. static boolean expand_body_expr(struct body_expr **ptr)
  2315. {
  2316.     expand_body((*ptr)->body, FALSE);
  2317.     return FALSE;
  2318. }
  2319.  
  2320. static boolean expand_method_expr(struct expr **ptr)
  2321. {
  2322.     struct method_expr *e = (struct method_expr *)*ptr;
  2323.     struct method *method = e->method;
  2324.  
  2325.     if (method->specializers) {
  2326.     expand_method_for_compile(method);
  2327.     return FALSE;
  2328.     }
  2329.     else {
  2330.     struct body *body = make_body();
  2331.     add_method_wrap(body, method);
  2332.     add_expr(body, (struct expr *)e);
  2333.     *ptr = make_body_expr(body);
  2334.     return TRUE;
  2335.     }
  2336. }
  2337.  
  2338. static boolean expand_loop_expr(struct loop_expr **ptr)
  2339. {
  2340.     expand_body((*ptr)->body, FALSE);
  2341.     return FALSE;
  2342. }
  2343.  
  2344. static boolean expand_repeat_expr(struct repeat_expr **ptr)
  2345. {
  2346.     /* No nothing. */
  2347.     return FALSE;
  2348. }
  2349.  
  2350. static boolean expand_error_expr(struct expr **ptr)
  2351. {
  2352.     lose("Called expand on a parse tree with errors?");
  2353.     return FALSE;
  2354. }
  2355.  
  2356. static boolean (*ExpressionExpanders[])() = {
  2357.     expand_varref_expr, expand_literal_expr, expand_call_expr,
  2358.     expand_method_expr, expand_dot_expr, expand_body_expr, expand_block_expr,
  2359.     expand_case_expr, expand_if_expr, expand_for_expr, expand_select_expr,
  2360.     expand_varset_expr, expand_binop_series_expr, expand_loop_expr,
  2361.     expand_repeat_expr, expand_error_expr
  2362. };
  2363.  
  2364. static void expand_expr(struct expr **ptr)
  2365. {
  2366.     struct expr *expr;
  2367.  
  2368.     do {
  2369.     expr = *ptr;
  2370.     } while ((*ExpressionExpanders[(int)expr->kind])(ptr));
  2371. }
  2372.  
  2373.  
  2374. /* Expand */
  2375.  
  2376. static void expand_body(struct body *body, boolean top_level)
  2377. {
  2378.     struct constituent **prev, *next;
  2379.  
  2380.     if (body->head == NULL)
  2381.     body->head
  2382.         = make_expr_constituent(make_literal_ref(make_false_literal()));
  2383.  
  2384.     prev = &body->head;
  2385.     do {
  2386.     next = (*prev)->next;
  2387.     while (expand_constituent(prev, top_level))
  2388.         ;
  2389.     prev = &(*prev)->next;
  2390.     *prev = next;
  2391.     } while (next);
  2392. }
  2393.  
  2394. void expand(struct body *body)
  2395. {
  2396.     expand_body(body, TRUE);
  2397. }
  2398.  
  2399.  
  2400. /* Call src->src transforms */
  2401.  
  2402. static void free_function_ref(struct expr *expr)
  2403. {
  2404.     struct varref_expr *varref = (struct varref_expr *)expr;
  2405.  
  2406.     free(varref->var);
  2407.     free(varref);
  2408. }
  2409.  
  2410. static boolean srctran_varref_assignment(struct expr **ptr)
  2411. {
  2412.     struct call_expr *e = (struct call_expr *)*ptr;
  2413.     struct argument *args = e->args;
  2414.     struct varref_expr *varref = (struct varref_expr *)args->expr;
  2415.     struct argument *value = args->next;
  2416.  
  2417.     *ptr = make_varset(varref->var, value->expr);
  2418.  
  2419.     free(value);
  2420.     free(varref);
  2421.     free(args);
  2422.     free_function_ref(e->func);
  2423.     free(e);
  2424.  
  2425.     return TRUE;
  2426. }
  2427.  
  2428. static boolean srctran_call_assignment(struct expr **ptr)
  2429. {
  2430.     struct call_expr *e = (struct call_expr *)*ptr;
  2431.     struct argument *args = e->args;
  2432.     struct call_expr *comb = (struct call_expr *)args->expr;
  2433.     struct argument *value = args->next;
  2434.     struct body *body;
  2435.     struct symbol *temp;
  2436.  
  2437.     if (comb->func->kind != expr_VARREF)
  2438.     return FALSE;
  2439.     change_to_setter(((struct varref_expr *)comb->func)->var);
  2440.  
  2441.     temp = gensym();
  2442.     body = make_body();
  2443.     bind_temp(body, id(temp), value->expr);
  2444.  
  2445.     value->expr = make_varref(id(temp));
  2446.     value->next = comb->args;
  2447.     comb->args = value;
  2448.     add_expr(body, (struct expr *)comb);
  2449.  
  2450.     add_expr(body, make_varref(id(temp)));
  2451.  
  2452.     *ptr = make_body_expr(body);
  2453.  
  2454.     free(args);
  2455.     free_function_ref(e->func);
  2456.     free(e);
  2457.  
  2458.     return TRUE;
  2459. }
  2460.  
  2461. static boolean srctran_dot_assignment(struct expr **ptr)
  2462. {
  2463.     struct call_expr *e = (struct call_expr *)*ptr;
  2464.     struct argument *lhs = e->args;
  2465.     struct dot_expr *dot = (struct dot_expr *)lhs->expr;
  2466.     struct argument *value = lhs->next;
  2467.     struct expr *func = dot->func;
  2468.     struct arglist *args;
  2469.     struct body *body;
  2470.     struct symbol *temp;
  2471.  
  2472.     if (func->kind != expr_VARREF)
  2473.     return FALSE;
  2474.     change_to_setter(((struct varref_expr *)func)->var);
  2475.  
  2476.     temp = gensym();
  2477.     body = make_body();
  2478.     bind_temp(body, id(temp), value->expr);
  2479.  
  2480.     value->expr = make_varref(id(temp));
  2481.     args = add_argument(make_argument_list(), value);
  2482.     args = add_argument(args, make_argument(dot->arg));
  2483.     add_expr(body, make_function_call(dot->func, args));
  2484.  
  2485.     add_expr(body, make_varref(id(temp)));
  2486.  
  2487.     *ptr = make_body_expr(body);
  2488.  
  2489.     free(dot);
  2490.     free(lhs);
  2491.     free_function_ref(e->func);
  2492.     free(e);
  2493.  
  2494.     return TRUE;
  2495. }
  2496.  
  2497. static boolean srctran_assignment(struct expr **ptr)
  2498. {
  2499.     struct call_expr *e = (struct call_expr *)*ptr;
  2500.     struct argument *lhs = e->args;
  2501.  
  2502.     /* Make sure there are only two arguments. */
  2503.     if (lhs==NULL || lhs->next==NULL || lhs->next->next!=NULL) {
  2504.     struct varref_expr *func = (struct varref_expr *)e->func;
  2505.     error(func->var->line, ":= invoked with other than two arguments");
  2506.     return FALSE;
  2507.     }
  2508.  
  2509.     switch (lhs->expr->kind) {
  2510.       case expr_VARREF:
  2511.     return srctran_varref_assignment(ptr);
  2512.  
  2513.       case expr_CALL:
  2514.     return srctran_call_assignment(ptr);
  2515.  
  2516.       case expr_DOT:
  2517.     return srctran_dot_assignment(ptr);
  2518.  
  2519.       default:
  2520.     {
  2521.         struct varref_expr *func = (struct varref_expr *)e->func;
  2522.         error(func->var->line, ":= applied to non-assignable expression.");
  2523.     }
  2524.     return FALSE;
  2525.     }
  2526. }
  2527.  
  2528. static boolean srctran_and(struct expr **ptr)
  2529. {
  2530.     struct call_expr *e = (struct call_expr *)*ptr;
  2531.     struct argument *arg = e->args;
  2532.  
  2533.     if (arg == NULL) {
  2534.     *ptr = make_literal_ref(make_false_literal());
  2535.     free_function_ref(e->func);
  2536.     }
  2537.     else if (arg->next == NULL) {
  2538.     *ptr = arg->expr;
  2539.     free_function_ref(e->func);
  2540.     free(arg);
  2541.     }
  2542.     else {
  2543.     e->args = arg->next;
  2544.     *ptr = make_if(arg->expr, make_expr_body((struct expr *)e), NULL);
  2545.     free(arg);
  2546.     }
  2547.     return TRUE;
  2548. }
  2549.  
  2550. static boolean srctran_or(struct expr **ptr)
  2551. {
  2552.     struct call_expr *e = (struct call_expr *)*ptr;
  2553.     struct argument *arg = e->args;
  2554.  
  2555.     if (arg == NULL) {
  2556.     *ptr = make_literal_ref(make_true_literal());
  2557.     free_function_ref(e->func);
  2558.     }
  2559.     else if (arg->next == NULL) {
  2560.     *ptr = arg->expr;
  2561.     free_function_ref(e->func);
  2562.     free(arg);
  2563.     }
  2564.     else {
  2565.     struct symbol *temp = gensym();
  2566.     struct body *body = make_body();
  2567.  
  2568.     e->args = arg->next;
  2569.     bind_temp(body, id(temp), arg->expr);
  2570.     add_expr(body,
  2571.          make_if(make_varref(id(temp)),
  2572.              make_expr_body(make_varref(id(temp))),
  2573.              make_else(0, make_expr_body((struct expr *)e))));
  2574.     *ptr = make_body_expr(body);
  2575.     free(arg);
  2576.     }
  2577.  
  2578.     return TRUE;
  2579. }
  2580.  
  2581.  
  2582.  
  2583. /* Initialization stuff. */
  2584.  
  2585. static void set_srctran(char *name, boolean (*srctran)(), boolean internal)
  2586. {
  2587.     struct id *identifier = id(symbol(name));
  2588.     struct function_info *info;
  2589.  
  2590.     identifier->internal = internal;
  2591.     info = lookup_function_info(identifier, TRUE);
  2592.     info->srctran = srctran;
  2593.  
  2594.     free(identifier);
  2595. }
  2596.  
  2597. void init_expand(void)
  2598. {
  2599.     set_srctran(":=", srctran_assignment, TRUE);
  2600.     set_srctran(":=", srctran_assignment, FALSE);
  2601.     set_srctran("&", srctran_and, TRUE);
  2602.     set_srctran("&", srctran_and, FALSE);
  2603.     set_srctran("|", srctran_or, TRUE);
  2604.     set_srctran("|", srctran_or, FALSE);
  2605. }
  2606.